; ORIGINAL: 3dt2.1/examples/schemers/dice.scm
;;
;; dice.scm
;;
;; A collection of programs fulfilling the goals of the DICE project in
;; Chapter 4 of the "Getting Started" book.
;;
;; Edward C. Martin, Schemers Inc.
;; 20 December 1993
;;

;; Clear the slate.
;;
(part:clear)
(for-each view:delete (env:views))

;; Create a standard view.
;;
(load "std-view.scm")

;; Load default rendering and coloring.
;;
(load "rdrpaint.scm")

;; Create a basic, blank, cubical die.
;; The argument  s  is a positive real giving the length of side of the
;; cube. The die is centered at the origin.
;;
(define blank
  (lambda (s)
    (let ((h (* 0.5 s)))
      (solid:block
        (position (- h) (- h) (- h)) (position h h h)))))

;;
;; WCS procedures. Each one, when applied to a number  s,  creates a wcs with
;; its origin at one corner of the square face underlying a face of the die,
;; with its x- and y-axes along two adjacent sides of that face, and with its
;; z-axis along the face's outward normal.
;;
;; The argument  s  gives the length of side of the underlying cube.
;;
(define wcs1
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position (- h) (- h) h) (gvector 1 0 0) (gvector 0 1 0)))))

(define wcs2
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position h (- h) h) (gvector -1 0 0) (gvector 0 0 -1)))))

(define wcs3
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position h h h) (gvector 0 -1 0) (gvector 0 0 -1)))))

(define wcs4
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position (- h) (- h) h) (gvector 0 1 0) (gvector 0 0 -1)))))

(define wcs5
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position (- h) h h) (gvector 1 0 0) (gvector 0 0 -1)))))

(define wcs6
  (lambda (s)
    (let ((h (* 0.5 s)))
      (wcs (position h (- h) (- h)) (gvector -1 0 0) (gvector 0 1 0)))))

;;
;; Pip position procedures. Each one, when applied to a number  s,  returns a
;; list of positions giving the centers of the spheres that will carve out
;; the pips on a face of the die. The positions are specified relative to a
;; wcs whose origin is at one corner of the corresponding face of the
;; underlying cube, whose x- and y-axes run along two adjacent edges of that
;; face, and whose z-axis is parallel to the face's outward normal.
;;
;; The argument  s  gives the length of side of the underlying cube.
;;
(define pips1
  (lambda (s)
    (let ((t1 (* 0.5 s)) (t2 (* 0.075 s)))
      (list (position t1 t1 t2)))))

(define pips2
  (lambda (s)
    (let ((t1 (* 0.3 s)) (t2 (* 0.7 s)) (t3 (* 0.075 s)))
      (list (position t1 t2 t3) (position t2 t1 t3)))))

(define pips3
  (lambda (s)
    (let ((t1 (* 0.3 s)) (t2 (* 0.5 s)) (t3 (* 0.7 s)) (t4 (* 0.075 s)))
      (list (position t1 t1 t4) (position t2 t2 t4) (position t3 t3 t4)))))

(define pips4
  (lambda (s)
    (let ((t1 (* 0.3 s)) (t2 (* 0.7 s)) (t3 (* 0.075 s)))
      (list (position t1 t2 t3) (position t2 t2 t3)
            (position t1 t1 t3) (position t2 t1 t3)))))

(define pips5
  (lambda (s)
    (let ((t1 (* 0.3 s)) (t2 (* 0.5 s)) (t3 (* 0.7 s)) (t4 (* 0.075 s)))
      (list (position t1 t3 t4) (position t3 t3 t4)
            (position t2 t2 t4)
            (position t1 t1 t4) (position t3 t1 t4)))))

(define pips6
  (lambda (s)
    (let ((t1 (* 0.3 s)) (t2 (* 0.5 s)) (t3 (* 0.7 s))
          (t4 (* 0.2 s)) (t5 (* 0.8 s)) (t6 (* 0.075 s)))
      (list (position t5 t1 t6) (position t5 t3 t6)
            (position t2 t1 t6) (position t2 t3 t6)
            (position t4 t1 t6) (position t4 t3 t6)))))

;;
;; Carve the pips out of one face of the input  blank  die.
;; The  ctr-list  argument is a list of the positions of the centers of the
;; spheres that will carve out the pips. The argument  rad  gives the radius
;; of each sphere.
;;
(define carve-pips
  (lambda (blank ctr-list rad)
    (apply solid:subtract
           (cons blank
                 (map (lambda (x) (solid:sphere x rad))
                      ctr-list)))))

;;
;; Create and display a rendered image of a die in the 1-up position,
;; based on a cube with sides of length  s.  The die will be colored
;; mainly in  die-clr  and the pips will be colored in  pip-clr.
;;
(define die
  (lambda (s die-clr pip-clr)
    (let ((old-auto (env:auto-display)))
      (env:set-auto-display OFF)
      (let ((D (blank s)))
        (entity:paint D die-clr)
        (for-each
          (lambda (coordsys pos)
            (wcs:set-active (coordsys s))
            (carve-pips D (pos s) (* 0.15 s))
            (wcs:set-active #f))
          (list wcs1 wcs2 wcs3 wcs4 wcs5 wcs6)
          (list pips1 pips2 pips3 pips4 pips5 pips6))
        (entity:delete
          (part:entities (filter:type "wcs?")))
        (for-each (lambda (ent) (entity:paint ent pip-clr))
                  (filter:apply (filter:type "face:spherical?")
                                (entity:faces D)))
        (solid:blend-edges
          (filter:apply (filter:type "edge:linear?") (entity:edges D))
          (* 0.065 s))
        (solid:intersect D (solid:sphere (position 0 0 0) (* 0.72 s)))
        (entity:facet D)
        (render D)
        (env:set-auto-display old-auto)
        D))))

;; end of file dice.scm
